home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 18 / fpc103.zip / PASM.SEQ < prev    next >
Text File  |  1988-06-30  |  25KB  |  701 lines
  1. \ PASM.SEQ    PREFIX & POSTFIX assembler by Robert L. Smith & Tom Zimmer
  2.  
  3. comment:
  4.  
  5.   An assembler for the 8086/8088, with both Prefix and Postfix syntax.
  6.  
  7.   PASM defaults to Prefix notation, but can be switched to F83 style
  8. Postfix notation with the word POSTFIX. To revert back to Prefix notation,
  9. use PREFIX.
  10.  
  11.   See the file ASSEM.TXT for a further description of the syntax.
  12.  
  13. comment;
  14.  
  15. 2VARIABLE APRIOR  4 ALLOT
  16.  
  17.         ' DROP APRIOR ! ' DROP APRIOR 4 + !
  18.  
  19. : <A;!>         ( A1 A2 --- )           \ Set up assembly instruction
  20.                 APRIOR 4 + 2! ;         \ completion function
  21.  
  22. : <A;>          ( --- )
  23.                 APRIOR 2@ EXECUTE       \ perform assembly completion
  24.                 APRIOR 4 + 2@ APRIOR 2! \ SET UP FOR NEXT PREVIOUS
  25.                 ['] DROP APRIOR 4 + ! ; \ Make it not care if it is redone.
  26.  
  27. : <RUN-A;>      ( --- )                 \ make sure we complete instruction
  28.                 <RUN> <A;> ;              \ at the end of each line.
  29.  
  30. DEFER A;!       ' <A;!>    IS A;!
  31. DEFER A;        ' <A;>     IS A;
  32. DEFER RUN-A;    ' <RUN-A;> IS RUN-A;
  33.  
  34. VARIABLE POSTVAR                        \ is this post fix notation?
  35.  
  36. : PREFIX        ( --- )
  37.                 ['] <A;!>    IS A;!
  38.                 ['] <A;>     IS A;
  39.                 ['] <RUN-A;> IS RUN-A;  POSTVAR OFF ;
  40.  
  41. : POSTFIX       ( --- )
  42.                 ['] EXECUTE  IS A;!
  43.                 ['] NOOP     IS A;
  44.                 ['] <RUN>    IS RUN-A;  POSTVAR ON ;
  45.  
  46. PREFIX          \ Default is PREFIX assembler.
  47.  
  48. : >PRE          R> R> POSTVAR @ >R >R >R PREFIX ;    \ Save and set PREFIX
  49.  
  50. : PRE>          R> R> R> IF POSTFIX THEN >R >R ;     \ Restore previous FIX
  51.  
  52. \ The ASSEMBLER follows:
  53. ONLY FORTH ALSO ASSEMBLER DEFINITIONS ALSO
  54.  
  55.  
  56. DEFER C,         FORTH ' C,       ASSEMBLER IS C,
  57. DEFER ,          FORTH ' ,        ASSEMBLER IS ,
  58. DEFER HERE       FORTH ' HERE     ASSEMBLER IS HERE
  59.  
  60. DEFER ?>MARK
  61. DEFER ?>RESOLVE
  62. DEFER ?<MARK
  63. DEFER ?<RESOLVE
  64.  
  65. HEX
  66.  
  67. 20 CONSTANT MAX_LABELS
  68.  
  69. CREATE SHORTLABELS MAX_LABELS 4 * ALLOT
  70.  
  71. : SXBYTE  ( n1 -- n2 )   DUP 80 AND IF FF00 OR THEN ;
  72.  
  73. : CLEAR_LABELS   ( -- )  SHORTLABELS MAX_LABELS 4 * 0 FILL ;
  74.  
  75. : CHECKLABEL   ( n -- m ) \ Or abort
  76.      DUP MAX_LABELS 1- U> ABORT"  Bad Label "
  77.      2* 2* SHORTLABELS + ;
  78.  
  79. : $     ( n1 -- n2 )
  80.      CHECKLABEL DUP @
  81.      IF  @  ELSE  2+ DUP @ SWAP HERE 2+ SWAP !
  82.          DUP 0= IF  HERE 2+ +  THEN
  83.      THEN ;
  84.  
  85. \ Labels for the Assembler.
  86.  
  87. : $RESOLVE   ( linkaddr -- )
  88.      @ DUP 0= IF  DROP EXIT  THEN  0
  89.      BEGIN
  90.           + DUP 1- C@ OVER HERE OVER -
  91.           DUP $7F > ABORT" Branch out of range!"
  92.           SWAP 1- C!
  93.           SXBYTE DUP 0=
  94.      UNTIL
  95.      2DROP ;
  96.  
  97. : $:F           ( N1 --- )
  98.                 CHECKLABEL DUP 2+ $RESOLVE  0 OVER 2+ !
  99.                 HERE SWAP ! ;
  100.  
  101. : $:            ( n -- )
  102.                 ['] $:F A;! A; ;
  103.  
  104. : L$            ( --- a1 )              \ Pass a1 to L$:
  105.                 0 A; HERE ;
  106.  
  107. : L$:           ( a1 --- )              \ a1 = addr passed by L$
  108.                 A; HERE OVER - SWAP 2- ! ;
  109.  
  110. comment:
  111.         Use L$ as follows:      \ Usable with JMP or CALL
  112.  
  113.                 JMP L$          \ Does a long jump to L$:
  114.                 ...
  115.                 ...             \ A bunch of bytes occur between these
  116.                 ...             \ instructions
  117.                 ...
  118.             L$: MOV X, X        \ Destination of long jump
  119. comment;
  120.  
  121. \ End of Local Label definitions
  122.  
  123.  
  124. FORTH DEFINITIONS
  125.  
  126. : DOASSEM       ( --- )
  127.                   ['] RUN-A; IS RUN
  128.                 0 ['] DROP A;!
  129.                 APRIOR 4 + 2@ APRIOR 2!
  130.                 ALSO ASSEMBLER ;
  131.  
  132. ' DOASSEM IS SETASSEM
  133.  
  134. : LABEL         ( NAME --- )            \ Really just a constant addr
  135.                 SETASSEM CREATE ;
  136.  
  137. : CODE          ( NAME --- )
  138.                 LABEL -3 DP +! HIDE ;
  139.  
  140. ASSEMBLER DEFINITIONS
  141.  
  142. : END-CODE      ['] <RUN> IS RUN
  143.                 PREVIOUS A; REVEAL ;
  144.  
  145. ' END-CODE ALIAS C;
  146.  
  147. \ 8088 Assembler, based on Ray Duncan's Dr. Dobb's article.
  148.  
  149. : ERROR3        ( --- )
  150.                 ['] DROP APRIOR 4 + !   \ Make it not care if it is redone.
  151.                 TRUE ABORT"  Illegal Operand "  ;
  152.  
  153. : ?ORDERERROR   ( F1 --- )
  154.                 IF      ['] DROP APRIOR 4 + !
  155.                         TRUE ABORT" Wrong Operand Order! "
  156.                 THEN    ;
  157.  
  158.  
  159. VARIABLE <#>   VARIABLE <TD>   VARIABLE <TS>   VARIABLE <RD>   VARIABLE <RS>
  160. VARIABLE <W>   VARIABLE <WD>   VARIABLE <OD>   VARIABLE <OS>   VARIABLE <D>
  161. VARIABLE <SP>  VARIABLE <FR>   VARIABLE <AO>   VARIABLE <ND>   VARIABLE <DST>
  162. VARIABLE <SST> VARIABLE <WS>   VARIABLE <ID>
  163.  
  164. : D>S           ( --- )                 \ Move destination to source.
  165.                 <TD> @ <TS> !
  166.                 <RD> @ <RS> !
  167.                 <OD> @ <OS> ! ;
  168.  
  169. : ?D>S          ( --- )                 \ Move Dest to Src if postfix
  170.                 <TS> @ 0=               \ If no source specified
  171.                 POSTVAR @ 0<> AND       \ and we are in postfix mode
  172.                 IF      D>S             \ Move destination to source
  173.                 THEN    ;
  174.  
  175. : ?D><S         ( --- )                 \ If no destinatiion specified
  176.                 <DST> @                 \ yet, then swap source and dest.
  177.                 IF      <TD> <TS> 2DUP @ SWAP @ ROT ! SWAP !
  178.                         <RD> <RS> 2DUP @ SWAP @ ROT ! SWAP !
  179.                         <OD> <OS> 2DUP @ SWAP @ ROT ! SWAP !
  180.                 THEN    <DST> OFF ;
  181.  
  182. : ?<SP>   <SP> @ SP@ - 2- 2/ ;
  183.  
  184. : <SREG>        ( A1 --- )
  185.                 POSTVAR @
  186.                 IF      <DST> OFF       \ Only reset dest if postfix
  187.                 THEN    <SST> ON
  188.                 DUP C@ DUP 0FF = IF DROP ELSE DUP <W> ! <WS> ! THEN
  189.                 1+ DUP C@ <TS> !
  190.                 1+ C@ <RS> !  <TS> @ 4 = IF ?<SP> 0 > IF <OS> ! THEN THEN ;
  191.  
  192. : <DREG>        ( A1 --- )
  193.                 <DST> ON
  194.                 DUP C@ DUP 0FF = IF DROP ELSE DUP <W> !  <WD> ! THEN
  195.                 1+ DUP C@ <TD> !  1+ C@ <RD> !  <#> @
  196.                 ABORT"  Immediate Data not allowed "
  197.                 <TD> @ 4 = IF ?<SP> 0 > IF <OD> ! THEN THEN ;
  198.  
  199. \ Destination Register processing.
  200.  
  201. : DREG          CREATE C, C, C, DOES> POSTVAR @
  202.                 IF      <SREG>
  203.                 ELSE    <DREG>
  204.                 THEN    ;
  205.  
  206. \ Source Register processing.
  207.  
  208. : SREG          CREATE C, C, C, DOES> POSTVAR @
  209.                 IF      <SST> @ IF <DREG> ELSE <SREG> THEN
  210.                 ELSE    <SREG>
  211.                 THEN    ;
  212.  
  213. \ Source Register Definitions
  214.  
  215. \    Reg  Type W        Name          Reg   Type  W        Name
  216.      0    2    0  SREG  AL            0     3     1  SREG  AX
  217.      1    2    0  SREG  CL            1     3     1  SREG  CX
  218.      2    2    0  SREG  DL            2     3     1  SREG  DX
  219.      3    2    0  SREG  BL            3     3     1  SREG  BX
  220.      4    2    0  SREG  AH            4     3     1  SREG  SP
  221.      5    2    0  SREG  CH            5     3     1  SREG  BP
  222.                                                 ' BP ALIAS RP
  223.      6    2    0  SREG  DH            6     3     1  SREG  SI
  224.                                       6     3     1  SREG  IP
  225.      7    2    0  SREG  BH            7     3     1  SREG  DI
  226.                                                           
  227.      0    4    -1 SREG  [BX+SI]       0     4     -1 SREG  [SI+BX]
  228.      0    4    -1 SREG  [BX+IP]       0     4     -1 SREG  [IP+BX]
  229.      1    4    -1 SREG  [BX+DI]       1     4     -1 SREG  [DI+BX]
  230.      2    4    -1 SREG  [BP+SI]       2     4     -1 SREG  [SI+BP]
  231.         ' [BP+SI] ALIAS [BP+IP]            ' [SI+BP] ALIAS [IP+BP]
  232.         ' [BP+SI] ALIAS [RP+IP]            ' [SI+BP] ALIAS [IP+RP]
  233.      3    4    -1 SREG  [BP+DI]       3     4     -1 SREG  [DI+BP]
  234.         ' [BP+DI] ALIAS [RP+DI]            ' [DI+BP] ALIAS [DI+RP]
  235.      4    4    -1 SREG  [SI]          5     4     -1 SREG  [DI]
  236.      4    4    -1 SREG  [IP]          7     4     -1 SREG  [BX]
  237.      6    4    -1 SREG  [BP]
  238.            ' [BP] ALIAS [RP]
  239.  
  240.      0    5    -1 SREG  ES            1     5     -1 SREG  CS
  241.      2    5    -1 SREG  SS            3     5     -1 SREG  DS
  242.                                                       
  243. \ Destination Register Definitions                    
  244.  
  245.      0    5    -1 DREG  ES,           1     5     -1 DREG  CS,
  246.      2    5    -1 DREG  SS,           3     5     -1 DREG  DS,
  247.                                                  
  248.      0    2    0  DREG  AL,           0     3     1  DREG  AX,
  249.      1    2    0  DREG  CL,           1     3     1  DREG  CX,
  250.      2    2    0  DREG  DL,           2     3     1  DREG  DX,
  251.      3    2    0  DREG  BL,           3     3     1  DREG  BX,
  252.      4    2    0  DREG  AH,           4     3     1  DREG  SP,
  253.      5    2    0  DREG  CH,           5     3     1  DREG  BP,
  254.                                                ' BP, ALIAS RP,
  255.      6    2    0  DREG  DH,           6     3     1  DREG  SI,
  256.                                                ' SI, ALIAS IP,
  257.      7    2    0  DREG  BH,           7     3     1  DREG  DI,
  258.                                                      
  259.      0    4    -1 DREG  [BX+SI],      0     4     -1 DREG  [SI+BX],
  260.      0    4    -1 DREG  [BX+IP],      0     4     -1 DREG  [IP+BX],
  261.      1    4    -1 DREG  [BX+DI],      1     4     -1 DREG  [DI+BX],
  262.      2    4    -1 DREG  [BP+SI],      2     4     -1 DREG  [SI+BP],
  263.      2    4    -1 DREG  [BP+IP],      2     4     -1 DREG  [IP+BP],
  264.      3    4    -1 DREG  [BP+DI],      3     4     -1 DREG  [DI+BP],
  265.      4    4    -1 DREG  [SI],         5     4     -1 DREG  [DI],
  266.           ' [SI], ALIAS [IP],
  267.      6    4    -1 DREG  [BP],         7     4     -1 DREG  [BX],
  268.           ' [BP], ALIAS [RP],
  269.  
  270. \ Miscellaneous Operators
  271. : TS@     <TS> @ ;
  272. : TD@     <TD> @ ;
  273. : RD@     <RD> @ ;
  274. : RS@     <RS> @ ;
  275. : +D      <D> @ 2* + ;
  276. : +W      <W> @ + ;
  277. : +RD     <RD> @ + ;
  278. : +RS     <RS> @ + ;
  279. : MOD1    3F AND 40 OR ;
  280. : MOD2    3F AND 80 OR ;
  281. : MOD3    3F AND C0 OR ;
  282. : RS0    <RS> @ 8 * ;
  283. : RSD    RS0 +RD ;
  284. : MD,    RS0 6 + C, ;
  285. : MS,    RD@ 8 * 6 + C, ;
  286. : RDS    RD@ 8 * +RS ;
  287. : CXD,   C@ MOD3 +RD C, ;
  288. : CXS,   C@ MOD3 +RS C, ;
  289.  
  290. \ Equates to Addressing Modes
  291.  
  292. 0 CONSTANT DIRECT       1 CONSTANT IMMED     2 CONSTANT REG8
  293. 3 CONSTANT REG16        4 CONSTANT INDEXED   5 CONSTANT SEGREG
  294.  
  295. \ Initialize all variables and flags
  296.  
  297. : RESET   0 <#> !   0 <W> !   0 <OS> !  0 <RD> !
  298.           0 <TD> !  0 <TS> !  0 <OD> !  0 <SP> !
  299.           0 <D> !   0 <WD> !  0 <RS> !  0 <FR> !  0 <ND> !
  300.           0 <DST> ! 0 <SST> ! 0 <WS> !  0 <ID> !  ;
  301.  
  302. : REG?     REG8 OVER = SWAP REG16 = OR ;
  303.  
  304. : DREG?   TD@ REG? ;
  305.  
  306. : ADREG?  DREG? RD@ ( 3 AND ) 0= AND ;
  307.  
  308. : ASREG?  TS@ REG? RS@ ( 3 AND ) 0= AND ;
  309.  
  310. : SUBREG  C@ 38 AND ;
  311.  
  312. : +S,     <AO> @
  313.                IF OVER 80 + 100 U< IF 2 OR C, C, ELSE C, , THEN
  314.                ELSE C, , THEN ;
  315.  
  316. \ Init. Direction Pointer
  317.  
  318. : DSET    TS@ DUP INDEXED = SWAP DIRECT = OR NEGATE <D> ! ;
  319.  
  320. : DT      1 <D> ! ;    \ Set Direction Flag True.
  321.  
  322. : OFFSET8,     HERE 1+ - DUP ABS OVER 0< + 7F >
  323.                ABORT"  Address out of range "  C, ;
  324.  
  325. : OFFSET16,    HERE 2+ - , ;
  326.  
  327. \ Calculate and store displacement for MEM/REG Instructions.
  328.  
  329. : DISP,   <D> @ IF <OS> ELSE <OD> THEN @ DUP
  330.                 IF DUP ABS 7F > IF SWAP MOD2 C, , ELSE SWAP MOD1 C, C, THEN
  331.                 ELSE DROP DUP 7 AND 6 = IF MOD1 C, 0 THEN C, THEN ;
  332.  
  333. \ Calculate the M/R 2nd operator byte
  334.  
  335. : M/RS,   38 AND TS@
  336.           CASE DIRECT  OF 6 + C, ,                   ENDOF
  337.              REG8    OF C0 + +RS C,                  ENDOF
  338.              REG16   OF C0 + +RS C,                  ENDOF
  339.              INDEXED OF <OS> @ 0= RS@ 6 <> AND
  340.                         IF      +RS C,
  341.                         ELSE    <OS> @ 80 + 100 U<
  342.                                 IF      40 + +RS C, <OS> @ C,
  343.                                 ELSE    80 + +RS C, <OS> @ ,
  344.                                 THEN
  345.                         THEN                         ENDOF
  346.              ERROR3                                    ENDCASE
  347.           ;
  348.  
  349. : M/RD,         ( ? --- ) D>S M/RS, ;
  350.  
  351. : 8/16,   <W> @ IF , ELSE C, THEN ;
  352.  
  353. \ Words to build the instructions:
  354.  
  355. : 1MIF          ( A1 --- )
  356.                 C@ C, RESET ;           \ Single Byte Inst.
  357.  
  358. : 1MI     CREATE C, DOES> ['] 1MIF A;! A; ;
  359.  
  360. : 1AMIF        ( A1 --- )               \ AX LODS or AX STOS
  361.                 C@ +W C, RESET ;           \ Single Byte Inst.
  362.  
  363. : 1AMI     CREATE C, DOES> ['] 1AMIF A;! A; ;
  364.  
  365. : 2MIF          ( A1 --- )
  366.                 C@ C, OFFSET8, RESET ;  \ Cond Jumps, Loops
  367.  
  368. : 2MI     CREATE C, DOES> ['] 2MIF A;! A; ;
  369.  
  370. : 3MI     CREATE C, DOES> C@ C, ;                       \ Segment Over-ride
  371.  
  372. : 4MIF          ( A1 --- )
  373.                 ?D>S TS@                \ Reg. Push and Pop
  374.           CASE
  375.                 SEGREG OF C@ RS@ 8 * + C,      ENDOF     \ SEGMENT
  376.                 REG16  OF 1+ C@ +RS C,         ENDOF       \ REGISTER
  377.                 REG8   OF ERROR3               ENDOF       \ 8 BIT ILLEGAL
  378.                        DROP 2+ C@ DUP C,
  379.                        30 AND M/RS,
  380.                                                ENDCASE    \ MEMORY
  381.           RESET ;
  382.  
  383. : 4MI     CREATE C, C, C, DOES> ['] 4MIF A;! A; ;
  384.  
  385. : 5MIF          ( A1 --- )
  386.                 ?D>S TS@                        \ Iseg. Jump, Call
  387.           CASE DIRECT  OF   <ND> @
  388.                             IF   0FF C, C@ <FR> @
  389.                                  IF  8 +  THEN  M/RS,
  390.                             ELSE <FR> @
  391.                                  IF  2+ C@ C, , ,
  392.                                  ELSE  OVER HERE 3 + - 80 + 100 U<
  393.                                          OVER C@ 20 = AND
  394.                                          <WD> @ 0= AND
  395.                                          IF  DROP 0EB C, OFFSET8,
  396.                                          ELSE 1+ C@ C, OFFSET16,
  397.                                          THEN
  398.                                  THEN
  399.                             THEN                                ENDOF
  400.              REG16   OF     0FF C, CXS,                         ENDOF
  401.              INDEXED OF     DSET 0FF C, C@ <FR> @
  402.                             IF  8 +  THEN  +RS DISP,            ENDOF
  403.              ERROR3                                             ENDCASE
  404.           RESET ;
  405.  
  406. : 5MI     CREATE C, C, C, DOES> ['] 5MIF A;! A; ;
  407.  
  408. : 6MIF          ( A1 --- )      \ IN and OUT
  409.                 DUP C@ 2 AND            \ IN or OUT?
  410.                 IF      <WS> @          \ This is an OUT
  411.                         ADREG? ?ORDERERROR
  412.                 ELSE    <WD> @          \ This is an IN
  413.                         ASREG? ?ORDERERROR
  414.                 THEN    SWAP <ID> @     \ WAS THERE IMMEDIATE DATA ?
  415.                 IF         C@ + ( +W ) C, C,
  416.                 ELSE    1+ C@ + ( +W ) C,
  417.                 THEN    RESET ;
  418.  
  419.  
  420. : 6MI     CREATE C, C, DOES> ['] 6MIF A;! A; ;
  421.  
  422. \ ADC, ADD, AND, etc.
  423.  
  424. : 7MIF          ( A1 --- )
  425.                 DUP 1+ C@ 1 AND <AO> !
  426.           TS@ IMMED =
  427.           IF ADREG?
  428.                IF 2+ C@ +W C, TD@ REG8 = IF C, ELSE , THEN
  429.                ELSE DUP 1+ C@ FE AND +W ROT >R  \ Save IMMEDiate data
  430.                     <AO> @
  431.                     IF  R@ 80 + 100 U<
  432.                          IF     2 OR C, C@ M/RD, R@ C,
  433.                          ELSE        C, C@ M/RD, R@ ,
  434.                          THEN
  435.                     ELSE             C, C@ M/RD, R@ 8/16,
  436.                     THEN   r>drop              \ Clean Return stack
  437.                THEN
  438.           ELSE C@ TS@ REG?
  439.                IF +W C, RS@ 8 * M/RD,
  440.                ELSE 84 OVER - IF 2 OR THEN +W C, TD@ REG?
  441.                     IF RD@ 8 * M/RS, ELSE ERROR3 THEN
  442.                THEN
  443.           THEN RESET ;
  444.  
  445. : 7MI     CREATE C, C, C, DOES> ['] 7MIF A;! A; ;
  446.  
  447. : 8MIF          ( A1 --- )
  448.                 ?D>S
  449.                 DUP 1+ C@ +W C, C@ M/RS, RESET ;
  450.  
  451. : 8MI     CREATE C, C, DOES> ['] 8MIF A;! A; ;
  452.  
  453. : 9MIF          ( A1 --- )
  454.                 <DST> @ 0=
  455.                 IF      1 <DST> ! ?D><S
  456.                         1 <TS> ! 1 <SST> !      \ : #  1 <TS> !  1 <SST> ! ;
  457.                         1 SWAP  <W> @ <WD> !
  458.                 ELSE    POSTVAR @               \ If postfix, reverse
  459.                         IF      ?D><S           \ the operands
  460.                                 <WS> @ <WD> !   \ Correct word mode
  461.                         THEN
  462.                 THEN
  463.                 DUP 1+ C@ <WD> @ +
  464.           TS@ 1 > IF 2+ C, ELSE C, NIP THEN  C@ M/RD, RESET ;
  465.  
  466. : 9MI           CREATE C, C, DOES> ['] 9MIF A;! A; ;
  467.  
  468. : 10MIF         ( A1 --- )
  469.                 DUP 1+ C@ C, C@ C, RESET ;
  470.  
  471. : 10MI          CREATE C, C, DOES> ['] 10MIF A;! A; ;
  472.  
  473. : 11MIF         ( A1 --- )
  474.                 ?D>S TS@ REG? <W> @ 0<> AND
  475.                 IF C@ +RS C, ELSE 1+ C@ FE +W C, M/RS, THEN RESET ;
  476.  
  477. : 11MI          CREATE C, C, DOES> ['] 11MIF A;! A; ;
  478.  
  479. : 12MIF         ( A1 --- )
  480.                 DROP                    \ MOV Instruction
  481.             TD@ SEGREG = IF 8E C,  RD@ 8 * M/RS,   ELSE
  482.             TS@ SEGREG = IF 8C C,  RS@ 8 * M/RD,   ELSE
  483.             TS@ IMMED = TD@ REG? AND
  484.                 IF 16 +W 8 * +RD C, 8/16,          ELSE
  485.             TS@ 0= TD@ 0= OR ADREG? ASREG? OR AND
  486.                 IF A0 +W TS@ IF 2+ THEN C, , ( 8/16, ) ELSE
  487.             TS@ IMMED = IF C6 +W C, >R 0 M/RD, R> 8/16, ELSE
  488.             88 +W TD@ REG?
  489.                         IF 2+ C, RD@ 8 * M/RS,      ELSE
  490.             TS@ REG? IF C, RS@ 8 * M/RD, ELSE ERROR3    THEN THEN THEN THEN
  491.                                                         THEN THEN THEN
  492.           RESET ;
  493.  
  494. : 12MI    CREATE DOES> ['] 12MIF A;! A; ;
  495.  
  496. : 13MIF         ( A1 --- )
  497.                 DROP    TS@ REG? TD@ REG? AND   \ Both are registers
  498.                         RS@ 0= RD@ 0= OR AND    \ Either register is AX
  499.                         <W> @ 1 = AND           \ And it is AX not AL.
  500.         IF      RS@ 0=
  501.                 IF      RD@
  502.                 ELSE    RS@
  503.                 THEN    90 + C,
  504.         ELSE    86 +W             \ XCHG Instruction
  505.           TS@ REG? 0=
  506.               IF TD@ REG? 0=
  507.                    IF   ERROR3
  508.                    ELSE C,
  509.                         RD@ 8 * M/RS,
  510.                    THEN
  511.               ELSE C, RS@ 8 * M/RD,
  512.               THEN
  513.         THEN    RESET ;
  514.  
  515. : 13MI    CREATE DOES> ['] 13MIF A;! A; ;
  516.  
  517. : 14MIF         ( A1 --- )
  518.                 C@ C, TD@ REG?
  519.               IF RD@ 8 * M/RS, ELSE ERROR3 THEN RESET ;
  520.  
  521. : 14MI    CREATE C, DOES> ['] 14MIF A;! A; ;
  522.  
  523. : 15MIF         ( A1 --- )
  524.                 DROP DUP 3 =
  525.           IF DROP CC C, ELSE CD C, C, THEN RESET ;
  526.  
  527. : 15MI    CREATE DOES> ['] 15MIF A;! A; ;
  528.  
  529. \ Now let's create the actual instructions.
  530.  
  531. 37        1MI   AAA      FC        1MI   CLD
  532. D5 0A    10MI   AAD      FA        1MI   CLI
  533. D4 0A    10MI   AAM      F5        1MI   CMC
  534. 3F        1MI   AAS      3C 81 38  7MI   CMP
  535. 14 81 10  7MI   ADC      A6        1MI   CMPSB
  536. 04 81 00  7MI   ADD      A7        1MI   CMPSW
  537. 24 80 20  7MI   AND      99        1MI   CWD
  538. 9A E8 10  5MI   CALL     27        1MI   DAA
  539. 98        1MI   CBW      2F        1MI   DAS
  540. F8        1MI   CLC      08 48    11MI   DEC
  541.  
  542. F6 30     8MI   DIV      73        2MI   JAE
  543. F4        1MI   HLT      72        2MI   JB
  544. F6 38     8MI   IDIV     76        2MI   JBE
  545. F6 28     8MI   IMUL     72        2MI   JC
  546. EC E4     6MI   IN       E3        2MI   JCXZ
  547. 00 40    11MI   INC      74        2MI   JE
  548.          15MI   INT      7F        2MI   JG
  549. CE        1MI   INTO     7D        2MI   JGE
  550. CF        1MI   IRET     7C        2MI   JL
  551. 77        2MI   JA       7E        2MI   JLE
  552.  
  553. EA E9 20  5MI   JMP      7F        2MI   JNLE
  554. 76        2MI   JNA      71        2MI   JNO
  555. 72        2MI   JNAE     7B        2MI   JNP
  556. 73        2MI   JNB      79        2MI   JNS
  557. 77        2MI   JNBE     75        2MI   JNZ
  558. 73        2MI   JNC      70        2MI   JO
  559. 75        2MI   JNE      7A        2MI   JP
  560. 7E        2MI   JNG      7A        2MI   JPE
  561. 7C        2MI   JNGE     7B        2MI   JPO
  562. 7D        2MI   JNL      78        2MI   JS
  563.  
  564. 74        2MI   JZ       E0        2MI   LOOPNE
  565. 9F        1MI   LAHF     E0        2MI   LOOPNZ
  566. C5       14MI   LDS      E1        2MI   LOOPZ
  567. 8D       14MI   LEA               12MI   MOV
  568. C4       14MI   LES      A4        1MI   MOVSB
  569. F0        1MI   LOCK     A5        1MI   MOVSW  A5      1MI   MOVS
  570. AC        1MI   LODSB    F6 20     8MI   MUL    AC      1AMI  LODS
  571. AD        1MI   LODSW    F6 18     8MI   NEG
  572. E2        2MI   LOOP     90        1MI   NOP
  573. E1        2MI   LOOPE    F6 10     8MI   NOT
  574.  
  575. 0C 80 08  7MI   OR       F2        1MI   REPNE
  576. EE E6     6MI   OUT      F2        1MI   REPNZ
  577. 8F 58 07  4MI   POP      F3        1MI   REPZ
  578. 9D        1MI   POPF     C3        1MI   RET
  579.                          CB        1MI   RETF
  580. FF 50 06  4MI   PUSH     D0 00     9MI   ROL
  581. 9C        1MI   PUSHF    D0 08     9MI   ROR
  582. D0 10     9MI   RCL      9E        1MI   SAHF
  583. D0 18     9MI   RCR      D0 38     9MI   SAR
  584. F3        1MI   REP      1C 81 18  7MI   SBB
  585. F3        1MI   REPE     AE        1MI   SCASB
  586.  
  587. AF        1MI   SCASW    AB        1MI   STOSW  AA      1AMI   STOS
  588. D0 20     9MI   SAL      2C 81 28  7MI   SUB
  589. D0 20     9MI   SHL      A8 F6 84  7MI   TEST
  590. D0 28     9MI   SHR      9B        1MI   WAIT
  591. F9        1MI   STC               13MI   XCHG
  592. FD        1MI   STD      D7        1MI   XLAT
  593. FB        1MI   STI      34 80 30  7MI   XOR
  594. AA        1MI   STOSB    \               ESC
  595.  
  596. \ Segment over-ride commands:
  597. 26        3MI   ES:
  598. 2E        3MI   CS:
  599. 36        3MI   SS:
  600. 3E        3MI   DS:
  601.  
  602. : FAR     1 <FR> ! ;
  603.  
  604. : BYTE    0 <W> !   0 <WD> ! ;
  605.  
  606. : WORD    1 <W> !   1 <WD> ! ;
  607.  
  608. : #       1 <TS> ! -1 <SST> ! 1 <ID> ! ;
  609.  
  610. : #)      ( ?D><S ) -1 <SST> !   \ Swap source and dest if no dest spec'ed.
  611.           1 <W> ! ;                \ Default to word mode
  612.  
  613. : []      0 <W> !  1 <ND> ! ;
  614.  
  615. : 3*      DUP 2* + ;
  616.  
  617. \ MACROS for NEXT, 1PUSH, and 2PUSH.
  618.  
  619. VARIABLE INLN           \ Flag to determine if we are compiling IN_LINE next.
  620.  
  621. : INLINEON      INLN ON ;
  622. : INLINEOFF     INLN OFF ;      INLINEOFF       \ Default to NO INLINE NEXT.
  623.  
  624. : NEXT          ( -- )
  625.                 >PRE    INLN @
  626.                 IF      LODSW ES: JMP AX    A;
  627.                 ELSE              JMP >NEXT A;
  628.                 THEN    PRE> ;
  629.  
  630. : 1PUSH         ( -- )
  631.                 >PRE    INLN @
  632.                 IF      PUSH AX LODSW ES: JMP AX       A;
  633.                 ELSE                      JMP >NEXT 1- A;
  634.                 THEN    PRE> ;
  635.  
  636. : 2PUSH         ( -- )
  637.                 >PRE    INLN @
  638.                 IF      PUSH DX PUSH AX LODSW ES: JMP AX       A;
  639.                 ELSE                              JMP >NEXT 2- A;
  640.                 THEN    PRE> ;
  641.  
  642. : A?>MARK    ( -- f addr ) TRUE   HERE   0 C,   ;
  643. : A?>RESOLVE ( f addr -- ) HERE OVER 1+ - SWAP C! ?CONDITION ;
  644. : A?<MARK    ( -- f addr ) TRUE   HERE   ;
  645. : A?<RESOLVE ( f addr -- ) HERE 1+ -  C,   ?CONDITION   ;
  646. ' A?>MARK    ASSEMBLER IS ?>MARK
  647. ' A?>RESOLVE ASSEMBLER IS ?>RESOLVE
  648. ' A?<MARK    ASSEMBLER IS ?<MARK
  649. ' A?<RESOLVE ASSEMBLER IS ?<RESOLVE
  650.  
  651. HEX
  652.  
  653. 75 CONSTANT 0=   74 CONSTANT 0<>   79 CONSTANT 0<
  654. 78 CONSTANT 0>=  7D CONSTANT <     7C CONSTANT >=
  655. 7F CONSTANT <=   7E CONSTANT >     73 CONSTANT U<
  656. 72 CONSTANT U>=  77 CONSTANT U<=   76 CONSTANT U>
  657. 71 CONSTANT OV   E3 CONSTANT CX<>0
  658.  
  659. DECIMAL
  660.  
  661. HEX
  662.  
  663. : IF      >R A; R> C,   ?>MARK  ;
  664. : THEN    A; ?>RESOLVE   ;
  665. : ELSE    0EB IF   2SWAP   THEN   ;
  666. : BEGIN   A; ?<MARK   ;
  667. : UNTIL   >R A; R> C,   ?<RESOLVE   ;
  668. : AGAIN   0EB UNTIL   ;
  669. : WHILE   IF   ;
  670. : REPEAT  A; 2SWAP   AGAIN   THEN   ;
  671. \ : DO      MOV # CX HERE   ;
  672.  
  673. FORTH DEFINITIONS
  674.  
  675. : INLINE        [COMPILE] [ SETASSEM HERE X, ; IMMEDIATE
  676.  
  677. ASSEMBLER DEFINITIONS
  678.  
  679. : END-INLINE    [ ASSEMBLER ] END-CODE ] ;
  680.  
  681. COMMENT:
  682.         \ Here is an example of how to use INLINE and END-INLINE to add
  683.         \ assembly code in the middle of a CODE definition.
  684.  
  685.         : TEST  ( --- )
  686.                 5 0
  687.                 DO I
  688.                         INLINE
  689.                                 pop ax
  690.                                 add ax, # 23
  691.                                 1push
  692.                         END-INLINE
  693.                         .
  694.                 LOOP ;
  695. COMMENT;
  696.  
  697. ONLY FORTH DEFINITIONS ALSO
  698.  
  699. DECIMAL
  700.  
  701.